home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / mpfeel.lha / MPFeel / threads.c < prev    next >
C/C++ Source or Header  |  1992-10-06  |  27KB  |  1,092 lines
  1. /* ******************************************************************** */
  2. /* threads.c         Copyright (C) Codemist and University of Bath 1989 */
  3. /*                                                                      */
  4. /* Lightweight processes                                        */
  5. /* ******************************************************************** */
  6.  
  7. /*
  8.  * $Id: threads.c,v 1.16 1992/03/13 18:10:07 pab Exp $
  9.  *
  10.  * $Log: threads.c,v $
  11.  * Revision 1.16  1992/03/13  18:10:07  pab
  12.  * SysV fixes (protection around semaphores)
  13.  *
  14.  * Revision 1.15  1992/02/10  12:02:38  pab
  15.  * Debugger addition, plus sysV fix
  16.  *
  17.  * Revision 1.14  1992/02/03  00:38:43  pab
  18.  * pre sysV hack
  19.  *
  20.  * Revision 1.13  1992/01/29  20:10:43  pab
  21.  * fewer exports in Generic version
  22.  *
  23.  * Revision 1.12  1992/01/29  13:51:00  pab
  24.  * sysV fixes
  25.  *
  26.  * Revision 1.11  1992/01/21  22:23:52  pab
  27.  * fixed call to garbage_collect
  28.  *
  29.  * Revision 1.10  1992/01/15  21:23:52  pab
  30.  * Fixed alignment problems; made threads allocate int arrays
  31.  *
  32.  * Revision 1.9  1992/01/09  22:29:10  pab
  33.  * Fixed for low tag ints
  34.  *
  35.  * Revision 1.8  1992/01/07  22:15:37  pab
  36.  * ncc compatable, plus backtrace
  37.  *
  38.  * Revision 1.7  1992/01/07  16:18:35  pab
  39.  * tidy of continuation fns
  40.  *
  41.  * Revision 1.6  1992/01/05  22:48:30  pab
  42.  * Minor bug fixes, plus BSD version
  43.  *
  44.  * Revision 1.5  1991/12/22  15:14:43  pab
  45.  * Xmas revision
  46.  *
  47.  * Revision 1.4  1991/11/15  13:45:47  pab
  48.  * copyalloc rev 0.01
  49.  *
  50.  * Revision 1.3  1991/09/22  19:14:43  pab
  51.  * Fixed obvious bugs
  52.  *
  53.  * Revision 1.2  1991/09/11  12:07:49  pab
  54.  * 11/9/91 First Alpha release of modified system
  55.  *
  56.  * Revision 1.1  1991/08/12  16:50:09  pab
  57.  * Initial revision
  58.  *
  59.  * Revision 1.11  1991/06/17  19:01:05  pab
  60.  * Adjusted set_assoc
  61.  *
  62.  * Revision 1.10  1991/06/17  18:58:28  kjp
  63.  * just in case
  64.  *
  65.  * Revision 1.9  1991/04/16  17:59:57  kjp
  66.  * Tidy.
  67.  *
  68.  * Revision 1.8  1991/03/01  15:50:12  kjp
  69.  * Fixed any machine version.
  70.  *
  71.  * Revision 1.7  1991/02/28  14:14:48  kjp
  72.  * Lots of good stuff.
  73.  *
  74.  * Revision 1.6  1991/02/13  18:26:27  kjp
  75.  * Pass.
  76.  *
  77.  */
  78.  
  79. #define COBUG(x) /* fprintf(stderr,"COBUG:");x;fflush(stderr) */
  80.  
  81. /*
  82.  * Change Log:
  83.  *   Version 1, April 1990
  84.  */
  85.  
  86. #include "defs.h"
  87. #include "structs.h"
  88. #include "funcalls.h"
  89.  
  90. #include "global.h"
  91. #include "error.h"
  92.  
  93. #include "calls.h"
  94. #include "modboot.h"
  95. #include "symboot.h"
  96.  
  97. #include "allocate.h"
  98. #include "modules.h"
  99. #include "threads.h"
  100. #include "class.h"
  101. #include "vectors.h"
  102. #include "garbage.h"
  103.  
  104. extern void free(void*);
  105. extern LispObject Thread_Class;
  106.  
  107. int command_line_x_debug;
  108.  
  109. /* *************************************************************** */
  110. /* Simple functions for all machines                               */
  111. /* *************************************************************** */
  112.  
  113. EUFUN_1( Fn_threadp, obj)
  114. {
  115.   return((is_thread(obj)?lisptrue:nil));
  116. }
  117. EUFUN_CLOSE
  118.  
  119. EUFUN_0( Fn_current_thread)
  120. {
  121.   return(CURRENT_THREAD());
  122. }
  123. EUFUN_CLOSE
  124.  
  125. EUFUN_1( Fn_continuationp, obj)
  126. {
  127.   return (is_continue(obj) ? lisptrue : nil);
  128. }
  129. EUFUN_CLOSE
  130.  
  131. /* *************************************************************** */
  132. /* When machines can actually do stuff                             */
  133. /* *************************************************************** */
  134.  
  135. #ifndef MACHINE_ANY
  136.  
  137. #define SCHEDBUG(x) /* fprintf(scheduler_debug,"%d:",system_scheduler_number); \
  138.                     x ;fflush(scheduler_debug) ;*/ /*while(getchar()!='\n');*/
  139. #define SDS (scheduler_debug)
  140.  
  141. #define SET_STATE(th) \
  142.   (set_continue(stacktop,((th)->THREAD.state)))
  143.  
  144. #define PROCEED(cont,value) \
  145.   stacktop = load_thread(cont->CONTINUE.thread); \
  146.   call_continue(stacktop,cont,value);
  147.  
  148. #define RUN_THREAD(th) \
  149.   PROCEED(((th->THREAD.state)),th->THREAD.args);
  150.  
  151. #define RUN_DISPATCHER(arg) \
  152.   { \
  153.     LispObject th = SYSTEM_THREAD_SPECIFIC_VALUE(local_dispatcher_thread); \
  154.     PROCEED(((th->THREAD.state)),arg); \
  155.   }
  156.  
  157. #define STACK_FIDDLE (16)
  158.  
  159. #define HOG_THREAD(th)
  160. #define RELEASE_THREAD(th)
  161.  
  162. /* Queue for default scheduling methods... */
  163.  
  164. SYSTEM_GLOBAL(LispObject,list_ready_thread_queue);
  165. SYSTEM_GLOBAL(SystemSemaphore,list_ready_thread_queue_sem);
  166. static SYSTEM_THREAD_SPECIFIC_DECLARATION(LispObject,local_dispatcher_thread);
  167. static SYSTEM_GLOBAL(LispObject,current_dispatcher_function);
  168. static SYSTEM_GLOBAL(LispObject,list_dispatcher_threads);
  169.  
  170. /* Stack switch user... */
  171.  
  172. static SYSTEM_THREAD_SPECIFIC_DECLARATION(jmp_buf,rig_escape);
  173. static SYSTEM_THREAD_SPECIFIC_DECLARATION(LispObject,rig_thread);
  174.  
  175. /* REMEMBER: within this function, we're on the thread's stacks!!! */
  176.  
  177. void rig_thread_aux()
  178. {
  179.   LispObject *stacktop;
  180.   LispObject xx;
  181.  
  182.   LispObject thread = SYSTEM_THREAD_SPECIFIC_VALUE(rig_thread);
  183.   extern LispObject Fn_apply(LispObject*);
  184.  
  185.   if (!setjmp(thread->THREAD.state->CONTINUE.machine_state))
  186.     longjmp(SYSTEM_THREAD_SPECIFIC_VALUE(rig_escape),TRUE);
  187.  
  188.   stacktop = thread->THREAD.state->CONTINUE.gc_stack_pointer;
  189.   STACK_TMP(thread);
  190.   EUCALLSET_2(xx,
  191.           Fn_apply,thread->THREAD.fun,thread->THREAD.args);
  192.   UNSTACK_TMP(thread);
  193.   thread->THREAD.value=xx;
  194.   thread->THREAD.status = THREAD_RETURNED;
  195.  
  196.   STACK_TMP(thread);
  197.   SCHEDBUG((fprintf(SDS,"thread returned "),
  198.         EUCALL_2(Fn_print,thread,SchedOut)));
  199.   UNSTACK_TMP(thread);
  200.  
  201.   if (thread->THREAD.parent != nil) {
  202.     stacktop =load_thread(thread->THREAD.parent);
  203.     call_continue(stacktop,
  204.               ((thread->THREAD.parent->THREAD.state)),
  205.           thread->THREAD.value);
  206.   }
  207.  
  208.   RUN_DISPATCHER(thread);
  209. }
  210.   
  211. LispObject system_thread_rig(LispObject *stacktop, LispObject thread)
  212. {
  213.   
  214.   /* Allocate the stacks */
  215.  
  216.   STACK_TMP(thread);
  217.   thread->THREAD.stack_base
  218.     = (int *) allocate_stack(stacktop,thread->THREAD.stack_size*sizeof(int));
  219.   UNSTACK_TMP(thread);
  220.   STACK_TMP(thread);
  221.   thread->THREAD.gc_stack_base
  222.     = (LispObject *) allocate_stack(stacktop,thread->THREAD.gc_stack_size*sizeof(int));
  223.   UNSTACK_TMP(thread);
  224.   STACK_TMP(thread);
  225.   thread->THREAD.state->CONTINUE.gc_stack_pointer
  226.     = thread->THREAD.gc_stack_base;
  227.  
  228.   if (setjmp(SYSTEM_THREAD_SPECIFIC_VALUE(rig_escape))) return(thread);
  229.   SYSTEM_THREAD_SPECIFIC_VALUE(rig_thread) = thread;
  230.   
  231.   if (thread->THREAD.stack_base==NULL)
  232.     CallError(stacktop,"Rig: Got strange thread\n",thread,NONCONTINUABLE);
  233.  
  234.   /* The ~7 is to align on a nice boundary --- no real point making it a #define */
  235.   stack_switch_and_go(((int) (thread->THREAD.stack_base
  236.               + thread->THREAD.stack_size - STACK_FIDDLE)&(~7)),
  237.               (int) rig_thread_aux);
  238.  
  239.   return(nil);
  240. }
  241.  
  242. /*
  243.  * Free re-usable resources of unrunnable threads... 
  244.  */
  245.  
  246. void shut_down_thread(LispObject *stacktop,LispObject th)
  247. {
  248.   void deallocate_stack(LispObject *, char *, int);
  249.  
  250.   th->THREAD.state->CONTINUE.gc_stack_pointer = NULL;
  251.   STACK_TMP(th);
  252.   deallocate_stack(stacktop,(char *) (th->THREAD.stack_base), 
  253.          th->THREAD.stack_size*sizeof(int));
  254.   deallocate_stack(stacktop,(char *) (th->THREAD.gc_stack_base),
  255.          th->THREAD.gc_stack_size*sizeof(int));
  256.   UNSTACK_TMP(th);
  257.   th->THREAD.stack_base = NULL;
  258.   th->THREAD.gc_stack_base = NULL;
  259.  
  260. /*
  261.   th->THREAD.stack_size = 0;
  262.   th->THREAD.gc_stack_size = 0;
  263. */
  264. }
  265.  
  266. /* Simple thread creation... */
  267.  
  268. #define MIN_THREAD_STACK_SIZE (4*1024)
  269. #define GC_STACK_RATIO        (4)
  270.  
  271. static SYSTEM_GLOBAL(LispObject,default_thread_stack_size);
  272.  
  273. EUFUN_0( Fn_default_thread_stack_size)
  274. {
  275.   return(SYSTEM_GLOBAL_VALUE(default_thread_stack_size));
  276. }
  277. EUFUN_CLOSE
  278.  
  279. EUFUN_1( Fn_default_thread_stack_size_setter, size)
  280. {
  281.   int csize;
  282.  
  283.   if (!is_fixnum(size))
  284.     CallError(stacktop,"(setter default-thread-stack-size): non-integer",
  285.           size,NONCONTINUABLE);
  286.  
  287.   csize = intval(size);
  288.  
  289.   if (csize < MIN_THREAD_STACK_SIZE)
  290.     CallError(stacktop,"(setter default-thread-stack-size): too small",
  291.           size,NONCONTINUABLE);
  292.  
  293.   SYSTEM_GLOBAL_VALUE(default_thread_stack_size) = size;
  294.  
  295.   return(size);
  296. }
  297. EUFUN_CLOSE
  298.   
  299. EUFUN_2(Fn_make_thread, fun, args)
  300. {
  301.   LispObject thread;
  302.  
  303.   if (!is_cons(args)) {
  304.  
  305.     thread 
  306.       = 
  307.     (LispObject) 
  308.       allocate_thread(stacktop,
  309.               intval(SYSTEM_GLOBAL_VALUE(default_thread_stack_size)),
  310.               intval(SYSTEM_GLOBAL_VALUE(default_thread_stack_size)),
  311.               0);
  312.   }
  313.   else {
  314.     LispObject size;
  315.     int csize;
  316.  
  317.     if (!is_fixnum((size = CAR(args))))
  318.       CallError(stacktop,"make-thread: invalid size",size,NONCONTINUABLE);
  319.  
  320.     csize = intval(size);
  321.  
  322.     if (csize <= 0)
  323.       CallError(stacktop,"make-thread: negative size",size,NONCONTINUABLE);
  324.  
  325.     if (csize < MIN_THREAD_STACK_SIZE)
  326.       CallError(stacktop,
  327.         "make-thread: size less than minimun",size,NONCONTINUABLE);
  328.  
  329.     thread = (LispObject) allocate_thread(stacktop,ALIGN_SIZE(csize),
  330.                       ALIGN_SIZE(csize/GC_STACK_RATIO),0);
  331.   }
  332.  
  333.   fun = ARG_0(stackbase);
  334.   thread->THREAD.fun = fun;
  335.   thread->THREAD.status = THREAD_LIMBO;
  336.  
  337.   return(thread);
  338. }
  339. EUFUN_CLOSE
  340.  
  341. EUFUN_1( Fn_thread_reset, th)
  342. {
  343.   if (!is_thread(th))
  344.     CallError(stacktop,"thread-reset: non thread",th,NONCONTINUABLE);
  345.  
  346.   if (th->THREAD.status != THREAD_RETURNED 
  347.        && th->THREAD.status != THREAD_ABORTED)
  348.     CallError(stacktop,"thread-reset: thread in use",th,NONCONTINUABLE);
  349.  
  350.   (void) system_thread_rig(stacktop,th);
  351.  
  352.   th = ARG_0(stackbase);
  353.   th->THREAD.value = nil;
  354.   th->THREAD.status = THREAD_LIMBO;
  355.  
  356.   return(th);
  357. }
  358. EUFUN_CLOSE
  359.  
  360. LispObject generic_thread_call;
  361.  
  362. EUFUN_2(Fn_thread_call, thread, args)
  363. {
  364.   LispObject me;
  365.  
  366.   if (!is_thread(thread))
  367.     CallError(stacktop,"thread-call: non-thread",thread,NONCONTINUABLE);
  368.  
  369.   if (thread->THREAD.status != THREAD_LIMBO)
  370.     CallError(stacktop,
  371.           "thread-call: thread not in limbo",thread,NONCONTINUABLE);
  372.  
  373.   /* Liberate the thread... */
  374.  
  375.   HOG_THREAD(thread);
  376.  
  377.   thread->THREAD.status = THREAD_RUNNING;
  378.   thread->THREAD.args = args;
  379.   me = CURRENT_THREAD();
  380.  
  381.   SCHEDBUG((fprintf(SDS,"Thread call from "), 
  382.         EUCALL_2(Fn_prin,me,SchedOut), 
  383.         fprintf(SDS," to "), 
  384.         EUCALL_2(Fn_print,th,SchedOut)));
  385.  
  386.   thread->THREAD.parent = me;
  387.  
  388.   RELEASE_THREAD(thread);
  389.  
  390.   if (SET_STATE(me)) {
  391.  
  392.     /* On caller... */
  393.  
  394.     SCHEDBUG((fprintf(SDS,"thread call returned to "),
  395.           EUCALL_2(Fn_print,me,SchedOut)));
  396.     
  397.     thread=ARG_0(stackbase);
  398.     thread->THREAD.parent = nil;
  399.     shut_down_thread(stacktop,thread);
  400.  
  401.     return(thread->THREAD.value);
  402.   }
  403.  
  404.   RUN_THREAD(thread);
  405.  
  406.   return(nil); /* Shouldn't get here */
  407. }
  408. EUFUN_CLOSE
  409.  
  410. /* Run on the dispatcher thread... */
  411.  
  412. EUFUN_1( Fn_next_ready_thread, c)
  413. {
  414.   LispObject thread;
  415.  
  416.   /* Peek... */
  417.  
  418.   if (SYSTEM_GLOBAL_VALUE(list_ready_thread_queue) == nil) return(nil);
  419.  
  420.   /* For real... */
  421.  
  422.   system_open_semaphore(stacktop,
  423.             &SYSTEM_GLOBAL_VALUE(list_ready_thread_queue_sem));
  424.   if (SYSTEM_GLOBAL_VALUE(list_ready_thread_queue) == nil) {
  425.     system_close_semaphore(&SYSTEM_GLOBAL_VALUE(list_ready_thread_queue_sem));
  426.     return(nil);
  427.   }
  428.  
  429.   thread = CAR(SYSTEM_GLOBAL_VALUE(list_ready_thread_queue));
  430.   SYSTEM_GLOBAL_VALUE(list_ready_thread_queue)
  431.     = CDR(SYSTEM_GLOBAL_VALUE(list_ready_thread_queue));
  432.  
  433.   system_close_semaphore(&SYSTEM_GLOBAL_VALUE(list_ready_thread_queue_sem));
  434.  
  435.   return(thread);
  436. }
  437. EUFUN_CLOSE
  438.  
  439. EUFUN_1( Fn_run_ready_thread, th)
  440. {
  441.  
  442. /*
  443.   #ifdef MACHINE_SYSTEMV
  444.   fprintf(stderr,"{R(%x):%x}",system_scheduler_number,(int) th);
  445.   fflush(stderr);
  446.   #endif
  447. */
  448.  
  449.   while (th->THREAD.status != THREAD_READY); /* Hedge */
  450.  
  451.   if (SET_STATE(CURRENT_THREAD())) {
  452.     th=ARG_0(stackbase);
  453.     return(th);
  454.   }
  455.   th=ARG_0(stackbase);
  456.   /* Have we done the stack business yet? */
  457.  
  458.   if (th->THREAD.stack_base == NULL) {
  459.     system_thread_rig(stacktop,th);
  460.     th = ARG_0(stackbase);
  461.   }
  462.  
  463.   th->THREAD.status = THREAD_RUNNING;
  464.  
  465.   RUN_THREAD(th);
  466.  
  467.   return(nil); /* Dummy */
  468. }
  469. EUFUN_CLOSE
  470.   
  471. #define SCHEDULER_RETRY_COUNT (1024) /* was 48*1024*/
  472.  
  473. EUFUN_0( Fn_dispatch)
  474. {
  475.   LispObject from = nil;
  476.   int tries = 0;
  477.  
  478.  restart:
  479.  
  480.   /*
  481.   if (SET_STATE(CURRENT_THREAD())) {
  482.     from = CURRENT_THREAD()->THREAD.state->CONTINUE.value;
  483.     goto restart;
  484.   }
  485.   */
  486.  
  487.   if (is_thread(from)) {
  488.  
  489.     switch (from->THREAD.status) {
  490.  
  491.      case THREAD_RETURNED:
  492.      case THREAD_ABORTED:
  493.  
  494.       (void) shut_down_thread(stacktop,from);
  495.       break;
  496.  
  497.      case THREAD_READY:
  498.  
  499.       {
  500.     LispObject cell = nil;
  501.     STACK_TMP(from); 
  502.     if (from->THREAD.cochain==nil)
  503.       {
  504.         LispObject xx;
  505.         xx=EUCALL_2(Fn_cons,nil,nil);
  506.         UNSTACK_TMP(from);
  507.         STACK_TMP(from);
  508.         from->THREAD.cochain=xx;
  509.         fprintf(stderr,"{}");
  510.       }
  511.     system_open_semaphore(stacktop,
  512.             &SYSTEM_GLOBAL_VALUE(list_ready_thread_queue_sem));
  513.     UNSTACK_TMP(from);
  514.     cell=from->THREAD.cochain;
  515.         
  516.     CAR(cell)=from;
  517.     CDR(cell)=nil;
  518.     EUCALLSET_2(SYSTEM_GLOBAL_VALUE(list_ready_thread_queue),
  519.             Fn_nconc,
  520.             SYSTEM_GLOBAL_VALUE(list_ready_thread_queue),cell);
  521.     system_close_semaphore(
  522.             &SYSTEM_GLOBAL_VALUE(list_ready_thread_queue_sem));
  523.     
  524.     break;
  525.       }
  526.  
  527.      default:
  528.  
  529.       break;
  530.     }
  531.  
  532.   }
  533.  
  534.   SCHEDBUG(printf("Setting dispatch state...\n"); fflush(stdout));
  535.  
  536.   SCHEDBUG(printf("Dispatching...\n"); fflush(stdout));
  537.  
  538.   tries = 0;
  539.   while (TRUE) {
  540.  
  541.     while (tries < SCHEDULER_RETRY_COUNT) {
  542.       LispObject thread;
  543.  
  544.       EUCALLSET_1(thread, Fn_next_ready_thread, Thread);
  545.       if (is_thread(thread)) {
  546.     EUCALLSET_1(from, Fn_run_ready_thread, thread);
  547.     STACK_TMP(from);
  548.     GC_sync_test();
  549.     UNSTACK_TMP(from);
  550.     goto restart;
  551.       }
  552.  
  553.       GC_sync_test();
  554.  
  555.       ++tries;
  556.     }
  557.  
  558.     system_sleep_until_kicked();
  559.  
  560.     GC_sync_test();
  561.  
  562.     tries = 0;
  563.   }
  564.  
  565.   return(nil);
  566. }
  567. EUFUN_CLOSE
  568.   
  569. EUFUN_2(Fn_thread_start, thread, args)
  570. {
  571.   COBUG(fprintf(stderr,"In thread-start\n"));
  572.  
  573.   if (!is_thread(thread))
  574.     CallError(stacktop,
  575.           "thread-start: non-thread argument",thread,NONCONTINUABLE);
  576.  
  577.   if (thread->THREAD.status != THREAD_LIMBO)
  578.     CallError(stacktop,
  579.           "thread-start: thread not in limbo",thread,NONCONTINUABLE);
  580.  
  581.   HOG_THREAD(thread);
  582.  
  583.   /* Place the args inside and wind her up... */
  584.  
  585.   thread->THREAD.status = THREAD_READY;
  586.   thread->THREAD.args = args;
  587.  
  588.   RELEASE_THREAD(thread);
  589.  
  590.   /* Bung it on the ready queue... */
  591.  
  592.   STACK_TMP(thread);
  593.   system_open_semaphore(stacktop,&SYSTEM_GLOBAL_VALUE(list_ready_thread_queue_sem));
  594.   UNSTACK_TMP(thread);
  595.   {
  596.     LispObject xx;
  597.     STACK_TMP(thread);
  598.     EUCALLSET_2(xx,Fn_cons,thread,nil);
  599.     
  600.     thread->THREAD.cochain=xx;
  601. /**    EUCALLSET_2(xx, Fn_cons,thread,nil);**/
  602.     CAR(thread->THREAD.cochain)=thread;
  603.     CDR(thread->THREAD.cochain)=nil;
  604.     EUCALLSET_2(SYSTEM_GLOBAL_VALUE(list_ready_thread_queue),
  605.         Fn_nconc, SYSTEM_GLOBAL_VALUE(list_ready_thread_queue),
  606.         thread->THREAD.cochain);
  607.   }
  608.   system_close_semaphore(&SYSTEM_GLOBAL_VALUE(list_ready_thread_queue_sem));
  609.  
  610.   /* All is cool... */
  611.  
  612.   /* Poke layabouts... */
  613.  
  614.   system_kick_sleepers();
  615.  
  616.   return(ARG_0(stackbase));
  617. }
  618. EUFUN_CLOSE
  619.  
  620. EUFUN_0( Fn_thread_reschedule)
  621. {
  622.   LispObject thread = CURRENT_THREAD();
  623.  
  624.   HOG_THREAD(thread);
  625.   if (SET_STATE(thread)) return(nil);
  626.   RELEASE_THREAD(thread);
  627.  
  628. #ifdef nope /* Mon Mar  2 12:54:29 1992 */
  629. /**/  /* following lines commented out --- probably wrong */
  630. /**/  system_open_semaphore(stacktop,&SYSTEM_GLOBAL_VALUE(list_ready_thread_queue_sem));
  631. /**/  SYSTEM_GLOBAL_VALUE(list_ready_thread_queue)
  632. /**/  = EUCALL_2(Fn_nconc,SYSTEM_GLOBAL_VALUE(list_ready_thread_queue), Fn_cons(thread,nil));
  633. /**/  system_close_semaphore(&SYSTEM_GLOBAL_VALUE(list_ready_thread_queue_sem));
  634. /**/  /**/
  635. #endif /* nope Mon Mar  2 12:54:29 1992 */
  636.  
  637.   /* Call the dispatcher... */
  638.  
  639.   thread->THREAD.status = THREAD_READY;
  640.   RUN_DISPATCHER(thread);
  641.  
  642.   return(nil);
  643. }
  644. EUFUN_CLOSE
  645.  
  646. EUFUN_0( Fn_thread_suspend)
  647. {
  648.   LispObject thread = CURRENT_THREAD();
  649.  
  650.   /* Must be running */
  651.   STACK_TMP(thread);
  652.  
  653.   if (SET_STATE(thread))
  654.     {    
  655.       thread=ARG_0(stackbase);
  656.       return(thread->THREAD.args);
  657.     }
  658.  
  659.   thread->THREAD.status = THREAD_LIMBO;
  660.  
  661.   RUN_DISPATCHER(nil);
  662.  
  663.   return(nil);
  664. }
  665. EUFUN_CLOSE
  666.  
  667. EUFUN_0( Fn_abort_thread)
  668. {
  669.   LispObject thread = CURRENT_THREAD();
  670.  
  671.   HOG_THREAD(thread);
  672.   thread->THREAD.status = THREAD_ABORTED;
  673.   RELEASE_THREAD(thread);
  674.  
  675.   RUN_DISPATCHER(nil);
  676.  
  677.   return(nil);
  678. }
  679. EUFUN_CLOSE
  680.  
  681. EUFUN_1( Fn_thread_value, thread)
  682. {
  683.   if (!is_thread(thread))
  684.     CallError(stacktop,"thread-value: non-thread",thread,NONCONTINUABLE);
  685.  
  686.  switchstart:
  687.   thread=ARG_0(stackbase);
  688.   switch (thread->THREAD.status) {
  689.  
  690.    case THREAD_RETURNED:  return(thread->THREAD.value);
  691.  
  692.    case THREAD_LIMBO:
  693.    case THREAD_RUNNING:
  694.    case THREAD_READY: 
  695.     {
  696.       EUCALL_0(Fn_thread_reschedule);
  697.       goto switchstart;
  698.     }
  699.  
  700.    case THREAD_ABORTED: 
  701.      CallError(stacktop,
  702.            "thread_value: thread aborted",thread,NONCONTINUABLE);
  703.  
  704.    default: CallError(stacktop,
  705.               "thread-value: bad thread status",thread,NONCONTINUABLE);
  706.   }
  707.  
  708.   return(nil);
  709. }
  710. EUFUN_CLOSE
  711.  
  712. static LispObject sym_limbo;
  713. static LispObject sym_ready;
  714. static LispObject sym_running;
  715. static LispObject sym_returned;
  716. static LispObject sym_aborted;
  717.  
  718. EUFUN_1( Fn_thread_state, th)
  719. {
  720.   if (!is_thread(th))
  721.     CallError(stacktop,"thread-state: non-thread",th,NONCONTINUABLE);
  722.  
  723.   switch (th->THREAD.status) {
  724.  
  725.    case THREAD_LIMBO:    return(sym_limbo);
  726.    case THREAD_READY:    return(sym_ready);
  727.    case THREAD_RUNNING:  return(sym_running);
  728.    case THREAD_RETURNED: return(sym_returned);
  729.    case THREAD_ABORTED:  return(sym_aborted);
  730.  
  731.    default: CallError(stacktop,"thread-state: weird state",th,NONCONTINUABLE);
  732.  
  733.   }
  734.  
  735.   return(nil); /* Dummy */
  736. }
  737. EUFUN_CLOSE
  738.  
  739. EUFUN_0( Fn_thread_queue)
  740. {
  741.   return(SYSTEM_GLOBAL_VALUE(list_ready_thread_queue));
  742. }
  743. EUFUN_CLOSE
  744.  
  745. EUFUN_0( Fn_kick)
  746. {
  747.   system_kick_sleepers();
  748.   return(nil);
  749. }
  750. EUFUN_CLOSE
  751.  
  752. /* *************************************************************** */
  753. /*                        Allocation Methods                       */
  754. /* *************************************************************** */
  755.  
  756. static LispObject sym_stack_size;
  757.  
  758. EUFUN_2( Md_allocate_instance_Thread_Class, c, il)
  759. {
  760.   extern LispObject search_keylist(LispObject*,LispObject,LispObject);
  761.   LispObject new,size;
  762.   int i;
  763.  
  764.   if ((size = search_keylist(stacktop,il,sym_stack_size)) == unbound)
  765.     size = SYSTEM_GLOBAL_VALUE(default_thread_stack_size);
  766.   else {
  767.     
  768.     if (!is_fixnum(size))
  769.       CallError(stacktop,"allocate-instance(thread): non-integer stack size",
  770.         size,NONCONTINUABLE);
  771.  
  772.     if (intval(size) < MIN_THREAD_STACK_SIZE)
  773.       CallError(stacktop,"allocate-instance(thread): stack size too small",
  774.         size,NONCONTINUABLE);
  775.  
  776.   }
  777.  
  778.   new = 
  779.     (LispObject) 
  780.       allocate_thread(stacktop,
  781.               intval(SYSTEM_GLOBAL_VALUE(default_thread_stack_size)),
  782.               intval(SYSTEM_GLOBAL_VALUE(default_thread_stack_size))
  783.                  / GC_STACK_RATIO,
  784.               c->CLASS.local_count);
  785.  
  786.   lval_classof(new) = ARG_0(stackbase);
  787.  
  788.   return(new);
  789. }
  790. EUFUN_CLOSE
  791.  
  792. EUFUN_2( Md_initialize_instance_Thread, t, il)
  793. {
  794.   extern LispObject Md_initialize_instance_1(LispObject*);
  795.   extern LispObject search_keylist(LispObject*,LispObject,LispObject);
  796.   LispObject fun;
  797.  
  798.   if ((fun = search_keylist(stacktop,il,sym_function)) == unbound)
  799.     CallError(stacktop,"allocate-instance(thread): missing function value",
  800.           il,NONCONTINUABLE);
  801.  
  802.   t->THREAD.fun = fun;
  803.   t->THREAD.status = THREAD_LIMBO;
  804.  
  805.   return(EUCALL_2(Md_initialize_instance_1,t,il));
  806. }
  807. EUFUN_CLOSE
  808.  
  809. #endif
  810.  
  811. /* *************************************************************** */
  812. /*                          Output Methods                         */
  813. /* *************************************************************** */
  814.  
  815. extern LispObject Gf_generic_prin(LispObject*);
  816. extern LispObject generic_generic_prin;
  817. extern LispObject generic_generic_write;
  818.  
  819. EUFUN_2( Md_generic_prin_Thread, t, str)
  820. {
  821.   if (!is_stream(str))
  822.     CallError(stacktop,"generic-prin: not a stream",str,NONCONTINUABLE);
  823.  
  824.   fprintf(str->STREAM.handle,"#<");
  825.   EUCALL_2(Gf_generic_prin,classof(t)->CLASS.name,str);
  826.   t = ARG_0(stackbase);
  827.   str = ARG_1(stackbase);
  828.   fprintf(str->STREAM.handle,": %x %x ",(int) t,t->THREAD.status);
  829.   EUCALL_2(Gf_generic_prin,t->THREAD.value,str);
  830.   fprintf(ARG_1(stackbase)->STREAM.handle,">");
  831.  
  832.   return(ARG_0(stackbase));
  833. }
  834. EUFUN_CLOSE
  835.  
  836. /* *************************************************************** */
  837. /* Test'n'debug                                                    */
  838. /* *************************************************************** */
  839.  
  840. #ifndef MACHINE_ANY
  841.  
  842. LispObject test_reschedule_runner(LispObject* stacktop)
  843. {
  844.   while (TRUE) (void) EUCALL_0(Fn_thread_reschedule);
  845.  
  846.   return(nil);
  847. }
  848.  
  849. EUFUN_1( Fn_test_reschedule, n)
  850. {
  851.   int cn;
  852.  
  853.   cn = intval(n);
  854.  
  855.   while (cn--) {
  856.     LispObject th;
  857.  
  858.     th = allocate_module_function(stacktop, NULL, NULL,
  859.                   test_reschedule_runner,0);
  860.     EUCALLSET_2(th, Fn_make_thread, th, nil);
  861.  
  862.     printf("Test: %x\n",(int) th); fflush(stdout);
  863.  
  864.     EUCALL_2(Fn_thread_start,th,nil);
  865.   }
  866.  
  867.   EUCALL_0(Fn_thread_suspend);
  868.  
  869.   return(nil);
  870. }
  871. EUFUN_CLOSE
  872.  
  873. EUFUN_0( Fn_test_gc)
  874. {
  875.   
  876.   while (1) garbage_collect(stacktop);
  877.  
  878.   return(nil);
  879. }
  880. EUFUN_CLOSE
  881.  
  882. #endif
  883.  
  884. /* so we know who we are... Note that this is an expensive function to call*/
  885. EUFUN_0(Fn_feel_arch)
  886. {
  887. #ifdef MACHINE_ANY
  888.   return(get_symbol(stacktop,"generic"));
  889. #elif defined(MACHINE_BSD)
  890.   return(get_symbol(stacktop,"BSD"));
  891. #endif
  892. #ifdef MACHINE_SYSTEMV
  893.   return(get_symbol(stacktop,"System-V"));
  894. #endif
  895.   /* NOTREACHED*/
  896.   return(get_symbol(stacktop,"something-strange"));
  897. }
  898. EUFUN_CLOSE
  899. /* *************************************************************** */
  900. /* Initialisation of this section                                  */
  901. /* *************************************************************** */
  902.  
  903. #ifdef MACHINE_ANY
  904. #define THREADS_ENTRIES 6
  905. #else
  906. #define THREADS_ENTRIES 25
  907. #endif
  908.  
  909. #define SET_ASSOC(a,b) \
  910.   { LispObject tmp,tmp2; \
  911.     STACK_TMP(a); \
  912.     tmp2=b; \
  913.     UNSTACK_TMP(tmp); \
  914.     set_anon_associate(stacktop,tmp,tmp2); \
  915.   }
  916.  
  917. MODULE Module_threads;
  918. LispObject Module_threads_values[THREADS_ENTRIES];
  919.  
  920. void initialise_threads(LispObject *stacktop)
  921. {
  922.   open_module(stacktop,
  923.           &Module_threads,Module_threads_values,"threads",THREADS_ENTRIES);
  924.  
  925.   (void) make_module_function(stacktop,"threadp",Fn_threadp,1);
  926.   (void) make_module_function(stacktop,"current-thread",Fn_current_thread,0);
  927.   (void) make_module_function(stacktop,"continuationp",Fn_continuationp,1);
  928.  
  929. #ifndef MACHINE_ANY
  930.  
  931.   sym_stack_size = get_symbol(stacktop,"stack-size");
  932.   add_root(&sym_stack_size);
  933.   sym_limbo = get_symbol(stacktop,"limbo");
  934.   add_root(&sym_limbo);
  935.   sym_ready = get_symbol(stacktop,"ready");
  936.   add_root(&sym_ready);
  937.   sym_running = get_symbol(stacktop,"running");
  938.   add_root(&sym_running);
  939.   sym_returned = get_symbol(stacktop,"returned");
  940.   add_root(&sym_returned);
  941.   sym_aborted = get_symbol(stacktop,"aborted");
  942.   add_root(&sym_aborted);
  943.  
  944.   SYSTEM_INITIALISE_GLOBAL(LispObject,
  945.                default_thread_stack_size,
  946.                allocate_integer(stacktop,MY_THREAD_STACK_SIZE));
  947.   ADD_SYSTEM_GLOBAL_ROOT(default_thread_stack_size);
  948.  
  949.   SYSTEM_INITIALISE_GLOBAL(LispObject,list_ready_thread_queue,nil);
  950.   ADD_SYSTEM_GLOBAL_ROOT(list_ready_thread_queue); 
  951.  
  952.   SYSTEM_INITIALISE_GLOBAL(LispObject,current_dispatcher_function,nil);
  953.   ADD_SYSTEM_GLOBAL_ROOT(current_dispatcher_function);
  954.  
  955.   SYSTEM_INITIALISE_GLOBAL(LispObject,list_dispatcher_threads,nil);
  956.   ADD_SYSTEM_GLOBAL_ROOT(list_dispatcher_threads);
  957.  
  958.   SYSTEM_INITIALISE_GLOBAL(SystemSemaphore,list_ready_thread_queue_sem,NULL);
  959.   system_allocate_semaphore(&SYSTEM_GLOBAL_VALUE(list_ready_thread_queue_sem));
  960.  
  961.   (void) make_module_function(stacktop,"make-thread",Fn_make_thread,-2);
  962.   (void) make_module_function(stacktop,"thread-start",Fn_thread_start,-2);
  963.   (void) make_module_function(stacktop,"thread-reschedule",Fn_thread_reschedule,0);
  964.  
  965.   (void) make_module_function(stacktop,"thread-call",Fn_thread_call,-2);
  966.   (void) make_module_function(stacktop,"thread-value",Fn_thread_value,1);
  967.   (void) make_module_function(stacktop,"thread-suspend",Fn_thread_suspend,0);
  968. #ifdef MACHINE_ANY
  969.   (void) make_module_entry(stacktop,"*threads-available*",nil);
  970. #else
  971.   (void) make_module_entry(stacktop,"*threads-available*",lisptrue);
  972. #endif
  973.   (void) make_module_function(stacktop,"generic_allocate_instance,Thread_Class",
  974.                   Md_allocate_instance_Thread_Class,2);
  975.   (void) make_module_function(stacktop,"generic_initialize_instance,Thread_Class", /* XXX bad name */
  976.                   Md_initialize_instance_Thread,2);
  977.  
  978.   SYSTEM_GLOBAL_VALUE(current_dispatcher_function)
  979.     = make_unexported_module_function(stacktop,"dispatcher",Fn_dispatch,0);
  980.  
  981.   (void) make_module_function(stacktop,"kick",Fn_kick,0);
  982.  
  983.   (void) make_module_function(stacktop,"not-thread-reset",Fn_thread_reset,1);
  984.  
  985.   (void) make_module_entry(stacktop,"*minimum-stack-size*",
  986.                allocate_integer(stacktop,MIN_THREAD_STACK_SIZE));
  987.  
  988.   (void) make_module_function(stacktop,"thread-state",Fn_thread_state,1);
  989.   (void) make_module_function(stacktop,"thread-queue",Fn_thread_queue,0);
  990.  
  991.   SET_ASSOC(make_module_function(stacktop,"default-thread-stack-size",
  992.                  Fn_default_thread_stack_size,
  993.                  0),
  994.         make_module_function(stacktop,"(setter default-thread-stack-size)",
  995.                  Fn_default_thread_stack_size_setter,
  996.                  1));
  997.        
  998.   (void) make_module_function(stacktop,"test-reschedule",Fn_test_reschedule,1);
  999.  
  1000.   (void) make_module_function(stacktop,"test-gc",Fn_test_gc,0);
  1001.  
  1002. #endif
  1003.  
  1004.   (void) make_module_function(stacktop,"generic_generic_prin,Thread,Object",
  1005.                   Md_generic_prin_Thread,2
  1006.                   );
  1007.   (void) make_module_function(stacktop,"generic_generic_write,Thread,Object",
  1008.                   Md_generic_prin_Thread,2
  1009.                   );
  1010.  
  1011.   (void) make_module_function(stacktop,"feel-machine-type",Fn_feel_arch,0);
  1012.  
  1013.   close_module();
  1014.  
  1015. }
  1016.  
  1017. #ifndef MACHINE_ANY
  1018.  
  1019. static SYSTEM_GLOBAL(int,start_register);
  1020.  
  1021. #define DISPATCHER_THREAD_STACK_SIZE (4*1048) /* Woz 4 */
  1022. #define DISPATCHER_THREAD_GC_STACK_SIZE (1024)
  1023.  
  1024. void runtime_begin_processes(LispObject* stacktop)
  1025. {
  1026.   extern void rig_gc_thread(LispObject *);
  1027.   extern int command_line_processors;
  1028.   int i;
  1029.  
  1030.   RUNNING_PROCESSORS() 
  1031.     = (command_line_processors == 0 ? 1 : command_line_processors);
  1032.  
  1033.   rig_gc_thread(stacktop);
  1034.  
  1035.   SYSTEM_INITIALISE_GLOBAL(int,start_register,0);
  1036.  
  1037.   for (i=0; i<RUNNING_PROCESSORS(); ++i) {
  1038.     int val;
  1039.     LispObject new_dt;
  1040.  
  1041.     /* Create and register dispatcher thread for each new process... */
  1042.  
  1043.     new_dt = allocate_thread(stacktop,
  1044.                  DISPATCHER_THREAD_STACK_SIZE,
  1045.                  DISPATCHER_THREAD_GC_STACK_SIZE,0);
  1046.  
  1047.     new_dt->THREAD.fun = SYSTEM_GLOBAL_VALUE(current_dispatcher_function);
  1048.  
  1049.     (void) system_thread_rig(stacktop,new_dt);
  1050.  
  1051.     EUCALLSET_2(SYSTEM_GLOBAL_VALUE(list_dispatcher_threads),
  1052.         Fn_cons,new_dt,SYSTEM_GLOBAL_VALUE(list_dispatcher_threads));
  1053.  
  1054.     val = (i == 0 ? 0 : fork());
  1055.  
  1056.     if (val == -1) {
  1057.       fprintf(stderr,"\nRats: fork wimped out\n\n"); fflush(stderr);
  1058.       system_lisp_exit(-1);
  1059.     }
  1060.     if (val == 0) { /* New! */
  1061.       SYSTEM_THREAD_SPECIFIC_VALUE(local_dispatcher_thread) = new_dt;
  1062.       add_root(&local_dispatcher_thread);
  1063. #ifndef NODEBUG
  1064.       startdb();
  1065. #endif
  1066.       if (i != 0) {
  1067.     runtime_reset_allocator(stacktop);
  1068.  
  1069.     break;
  1070.       }
  1071.  
  1072.     }
  1073.  
  1074.     ++SYSTEM_GLOBAL_VALUE(start_register);
  1075.  
  1076.   }
  1077.  
  1078.   system_register_process(i-1);
  1079.   SYSTEM_THREAD_SPECIFIC_VALUE(system_scheduler_number) = i-1;
  1080.  
  1081.   /* Wait for it... wait for it... */
  1082.  
  1083.   while (SYSTEM_GLOBAL_VALUE(start_register) != RUNNING_PROCESSORS());
  1084.   
  1085.   ON_collect();
  1086.  
  1087.   RUN_DISPATCHER(nil);
  1088. }
  1089.  
  1090. #endif
  1091.  
  1092.